home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr09 / cascad13.zip / CASCADE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-01  |  38KB  |  1,651 lines
  1. PROGRAM deschart;
  2.  
  3. {Documentation is contained in the accompanying file CASCADE.DOC}
  4.  
  5. CONST
  6.  
  7.     lines_per_page = 69;
  8.     lines_per_screen = 23;
  9.     indent_size = 5; {reduce this if you have very many generations to print}
  10.     maxfam = 2500; {increase this if there are more families in your database}
  11.     maxgen = 99; {default startup value and maximum;
  12.                     can also be increased if necessary}
  13.     texlines_per_page = 46;
  14.  
  15. TYPE
  16.  
  17.     twochr = string[2];
  18.     fchart = string[10];
  19.     fdate = string[20];
  20.     fmo = string[5];
  21.     fline = string[132];
  22.     indiv =                                    {packed INDIV2.DAT record}
  23.         RECORD
  24.             data : ARRAY[1..92] of BYTE;
  25.         END;
  26.     irec =                                    {unpacked INDIV2.DAT RECORD}
  27.         RECORD
  28.             surname : INTEGER;
  29.             given1 : INTEGER;
  30.             given2 : INTEGER;
  31.             given3 : INTEGER;
  32.             title : INTEGER;
  33.             sex : CHAR;
  34.             bdate : fdate;
  35.             bplace1 : INTEGER;
  36.             bplace2 : INTEGER;
  37.             bplace3 : INTEGER;
  38.             bplace4 : INTEGER;
  39.             cdate : fdate;
  40.             cplace1 : INTEGER;
  41.             cplace2 : INTEGER;
  42.             cplace3 : INTEGER;
  43.             cplace4 : INTEGER;
  44.             ddate : fdate;
  45.             dplace1 : INTEGER;
  46.             dplace2 : INTEGER;
  47.             dplace3 : INTEGER;
  48.             dplace4 : INTEGER;
  49.             budate : fdate;
  50.             buplace1 : INTEGER;
  51.             buplace2 : INTEGER;
  52.             buplace3 : INTEGER;
  53.             buplace4 : INTEGER;
  54.             bapdate : fdate;
  55.             baptemp : INTEGER;
  56.             endowdate : fdate;
  57.             endowtemp : INTEGER;
  58.             sealdate : fdate;
  59.             sealtemp : INTEGER;
  60.             sib : INTEGER;
  61.             marr : INTEGER;
  62.             pmarr : INTEGER;
  63.             id : ARRAY[1..10] of CHAR;
  64.             note : INTEGER;
  65.         END;
  66.     dict =                                            {packed NAME2.DAT RECORD}
  67.         RECORD
  68.             lp : ARRAY[1..2] of BYTE;
  69.             name : ARRAY[1..17] of CHAR;
  70.             rp : ARRAY[1..2] of BYTE;
  71.         END;     {PROCEDURE gn below unpacks NAME2.DAT RECORDs}
  72.     marr =                                            {packed MARR2.DAT RECORD}
  73.         RECORD
  74.             data : ARRAY[1..28] of BYTE;
  75.         END;
  76.     mar =                                            {unpacked MARR2.DAT RECORD}
  77.         RECORD
  78.             husb : INTEGER;
  79.             wife : INTEGER;
  80.             child : INTEGER;
  81.             mardate : fdate;
  82.             mplace1 : INTEGER;
  83.             mplace2 : INTEGER;
  84.             mplace3 : INTEGER;
  85.             mplace4 : INTEGER;
  86.             sealdate : fdate;
  87.             sealtemp : INTEGER;
  88.             hoth : INTEGER;
  89.             woth : INTEGER;
  90.             divflg : CHAR;
  91.         END;
  92.     genptr = ^genrec;
  93.     genrec = {pointer structure for recursively compiling descendants chart}
  94.         RECORD
  95.             mar : ARRAY[1..10] of INTEGER;
  96.             marptr : INTEGER;
  97.             child : ARRAY[1..30] of INTEGER;
  98.             chptr : INTEGER;
  99.         END;
  100.     ascptr = ^ascrec;
  101.     ascrec = {pointer structure for recursively ascending pedigree chart}
  102.         RECORD
  103.             marptr:INTEGER;
  104.             wifptr:INTEGER;
  105.             tafel:REAL;
  106.             lp,rp:ascptr;
  107.         END;
  108.     families =
  109.         RECORD
  110.             mrino,pg:INTEGER;
  111.             chrt:REAL;
  112.         END;
  113.  
  114. VAR
  115.  
  116. {files set up so that the standard function SEEK can locate
  117. entries from RIN, name IN and MRIN respectively}
  118.  
  119.     INDIV2 : file of indiv;
  120.     NAME2 : file of dict;
  121.     MARR2 : file of marr;
  122.  
  123. {configuration parameters}
  124.  
  125.     paging,maleline,print_on,surname,index,printtofile,tex_on,marrln : BOOLEAN;
  126.     multmarr,skipfam,firstchart,bothrem,done,stackempty,alldone : BOOLEAN;
  127.     root,no_gen,nogen_up: INTEGER;
  128.     num,rin,page_no,texpage,line_ct,texline_ct : INTEGER;
  129.     i,j,blen,clen,dlen,bulen : INTEGER;
  130.     famsdone,wed_no,total_pages:INTEGER;
  131.     stacksize :INTEGER;
  132.     parents_marr : integer;
  133.     ans : CHAR;
  134.     hdg,texhdg,tmplin : fline;
  135.     namelin,blin,dlin,mlin : fline;
  136.     namelin2,blin2,dlin2: fline;
  137.     tex_blin2,tex_dlin2: fline;
  138.     skip,ref,ref2:fline;
  139.     file_name,index_entry,tex_nlin,tex_blin,tex_dlin,tex_mlin:fline;
  140.     orchart,orpg:INTEGER;
  141.     baserec:irec;
  142.     stacktop,p:ascptr;
  143.     famdone:ARRAY[1..maxfam] OF families;
  144.     chartno,maxchart:REAL;
  145.     index_file,prnfile,texfile:TEXT;
  146.     lastmarr,youngest:ARRAY[1..maxgen]OF BOOLEAN;
  147.  
  148. {i and j are global counters;
  149. ans is CHAR response read from terminal;
  150. lin is the output line for the individual currently being
  151. processed;
  152. done is false until current chart is finished}
  153.  
  154. PROCEDURE mainmenu;
  155.  
  156. BEGIN (*mainmenu*)
  157.  
  158.     CLRSCR;
  159.     GOTOXY(32,2);
  160.     WRITE('CASCADE MAIN MENU');
  161.     GOTOXY(5,4);
  162.     WRITE('1. Toggle paging / scrolling (currently ');
  163.     IF paging THEN
  164.         WRITE('paging).')
  165.     ELSE
  166.         WRITE('scrolling).');
  167.     GOTOXY(5,5);
  168.     WRITE('2. Toggle all descendants / male line only (currently ');
  169.     IF maleline THEN
  170.         WRITE('male line only).')
  171.     ELSE
  172.         WRITE('all descendants).');
  173.     GOTOXY(5,6);
  174.     WRITE('3. Toggle printer on / off (currently ');
  175.     IF print_on THEN
  176.         WRITE('on).')
  177.     ELSE
  178.         WRITE('off).');
  179.     GOTOXY(5,7);
  180.     WRITE('4. Toggle cascading by surname / by generation (currently ');
  181.     IF surname THEN
  182.         WRITE('by surname).')
  183.     ELSE
  184.         WRITE('by generation).');
  185.     GOTOXY(5,8);
  186.     WRITE('5. Toggle index file creation on / off (currently ');
  187.     IF index THEN
  188.         WRITE('on).')
  189.     ELSE
  190.         WRITE('off).');
  191.     GOTOXY(5,9);
  192.     WRITE('6. Toggle print file creation on / off (currently ');
  193.     IF printtofile THEN
  194.         WRITE('on).')
  195.     ELSE
  196.         WRITE('off).');
  197.     GOTOXY(5,10);
  198.     WRITE('7. Toggle TeX file creation on / off (currently ');
  199.     IF tex_on THEN
  200.         WRITE('on).')
  201.     ELSE
  202.         WRITE('off).');
  203.     GOTOXY(5,11);
  204.     WRITE('8. Change no. of generations on a chart (currently ',no_gen,').');
  205.     GOTOXY(5,12);
  206.     WRITE('9. Change no. of generations to cascade (currently ',nogen_up,').');
  207.     GOTOXY(5,13);
  208.     WRITE('A. Change root individual (currently ',root,').');
  209.     GOTOXY(5,14);
  210.     WRITE('B. Produce a single descendants chart.');
  211.     GOTOXY(5,15);
  212.     WRITE('C. Produce cascading descendants charts.');
  213.     GOTOXY(5,17);
  214.     WRITE('0. Return to system.');
  215.     GOTOXY(1,20);
  216.     FOR j:= 1 TO 80 DO
  217.         WRITE('-');
  218.     GOTOXY(5,19);
  219.     WRITE('Selection : ')
  220.  
  221. END; {mainmenu}
  222.  
  223. FUNCTION flip(a1,a2:BYTE) : INTEGER;
  224.  
  225. {Reverse the BYTEs of INTEGER values which are stored lo,hi by
  226. PAF. Arguments - two BYTEs. Returns an INTEGER.}
  227.  
  228. BEGIN {flip}
  229.     flip := a2*256+a1;
  230. END; {flip}
  231.  
  232. FUNCTION mnth(mo:INTEGER) : fmo;
  233.  
  234. {Return month names - not completely coded here for all month
  235. codes. Argument - month code - Returns 5 character string.}
  236.  
  237. BEGIN {mnth}
  238.     CASE mo OF
  239.         1: Mnth := ' Jan ';
  240.         2: Mnth := ' Feb ';
  241.         3: Mnth := ' Mar ';
  242.         4: Mnth := ' Apr ';
  243.         5: Mnth := ' May ';
  244.         6: Mnth := ' Jun ';
  245.         7: Mnth := ' Jul ';
  246.         8: Mnth := ' Aug ';
  247.         9: Mnth := ' Sep ';
  248.         10: Mnth := ' Oct ';
  249.         11: Mnth := ' Nov ';
  250.         12: Mnth := ' Dec ';
  251.         13: Mnth := 'NOTES';
  252.         ELSE Mnth := ' UNK ';
  253.     END; {case}
  254. END; {mnth}
  255.  
  256. function time:fchart;
  257.  
  258. type
  259.  regpack = record
  260.             ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  261.             end;
  262.  
  263. var
  264.  recpack:     regpack;            {assign record}
  265.  ah,al,ch,cl,dh: byte;
  266.  hour,min,sec: string[2];
  267.  
  268. begin
  269.  ah := $2c;                            {initialize correct registers}
  270.  with recpack do
  271.  begin
  272.     ax := ah shl 8 + al;
  273.  end;
  274.  intr($21,recpack);                 {call interrupt}
  275.  with recpack do
  276.  begin
  277.     str(cx shr 8,hour);             {convert to string}
  278.     IF cx shr 8 < 10 THEN
  279.         hour := '0'+hour;
  280.     str(cx mod 256,min);                    { " }
  281.     IF cx mod 256 < 10 THEN
  282.         min := '0'+min;
  283.     str(dx shr 8,sec);                    {    " }
  284.     IF dx shr 8 < 10 THEN
  285.         sec := '0'+sec;
  286.  end;
  287.  time := ' '+hour+':'+min+':'+sec+' ';
  288. end;
  289.  
  290. function Date: fdate;
  291.  
  292. type
  293.  
  294.     regpack = record
  295.                 ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
  296.             end;
  297.  
  298. var
  299.  
  300.     recpack:    regpack;                {record for MsDos call}
  301.     month,day:    string[2];
  302.     year:        string[4];
  303.     dx,cx:        integer;
  304.  
  305. begin
  306.     with recpack do
  307.         begin
  308.             ax := $2a shl 8;
  309.         end;
  310.     MsDos(recpack);                        { call function }
  311.     with recpack do
  312.         begin
  313.             str(cx,year);                        {convert to string}
  314.             str(dx mod 256,day);                    { " }
  315.             date := day + mnth(dx shr 8) + year + time;
  316.         end;
  317. end;
  318.  
  319. PROCEDURE gn(yx:INTEGER;VAR leng:INTEGER;VAR nam:fdate);
  320. {Return a name string and its length from the NAME2.DAT file. The
  321. length is important because this string must be concatenated
  322. character by character up to the length. If this is not done,
  323. extraneous data from your NAME2 file will appear in your output.
  324. Arguments - NAME2.DAT identification number. Output - name and
  325. its length.}
  326.  
  327. VAR
  328.     n : dict; {packed yx-th line of NAME2.DAT}
  329.     i : INTEGER;
  330.  
  331. BEGIN {gn}
  332.  
  333.     SEEK(NAME2,yx);
  334.     READ(NAME2,n);
  335.     IF yx > 0 THEN
  336.         BEGIN
  337.             nam := n.name;
  338.             leng := pos(chr(0),nam) - 1;
  339.         END
  340.     ELSE
  341.         BEGIN
  342.             nam := '';
  343.             leng := -1;
  344.         END
  345.  
  346. END; {gn}
  347.  
  348. PROCEDURE xdate(a1,a2,a3,a4:BYTE;VAR res:fdate);
  349.  
  350. {Extracts a packed date into a printable string. Arguments - four
  351. BYTEs of packed date. Output - date string. Main year is in
  352. second half of first BYTE and first half of second BYTE; month is
  353. in next 5 bits; day in next 5 bits; modifier in next 2 bits; and
  354. alternate year - e.g. 1987/1988 - in last BYTE.}
  355.  
  356. VAR
  357.     yr,mo,day,mfr : INTEGER;
  358.     x : string[4];
  359.     y,z : string[2];
  360.  
  361. BEGIN {xdate}
  362.     yr := a1*16+ a2 div 16;
  363.     mo := (a2-(a2 div 16)*16)*2 + a3 div 128;
  364.     day := (a3-(a3 div 128)*128) div 4;
  365.     mfr := a3-(a3 div 4)*4;
  366.     str(yr:4,x);
  367.     str(day:2,z);
  368.     CASE mfr OF
  369.         0: IF (yr > 0) or (mo > 0) or (day > 0) THEN
  370.             res := 'Bef '
  371.         ELSE
  372.             res := '';
  373.         1: res := 'Abt ';
  374.         2: res := '';
  375.         3: res := 'Aft ';
  376.     END;
  377.     IF day > 0 THEN
  378.         res := res+z;
  379.     IF mo > 0 THEN
  380.         res := res+MNTH(mo);
  381.     IF yr > 0 THEN
  382.         res := res+x;
  383.     IF a4 <> 0 THEN
  384.         BEGIN
  385.             yr := yr + a4;
  386.             str(yr:4,x);
  387.             res := res+'/'+x;
  388.         END;
  389. END; {xdate}
  390.  
  391. PROCEDURE unp_marr(marriage:marr;VAR x:mar);
  392.  
  393. {Extract MARR2.DAT information into useable form. Arguments -
  394. packed MARR2.DAT line. Output - unpacked marriage RECORD.}
  395.  
  396. VAR
  397.     i : INTEGER;
  398.  
  399. BEGIN {unp_marr}
  400.  
  401. WITH marriage,x DO
  402.     BEGIN {with}
  403.         husb := flip(data[1],data[2]);
  404.         wIFe := flip(data[3],data[4]);
  405.         child := flip(data[5],data[6]);
  406.         xdate(data[7],data[8],data[9],data[10],mardate);
  407.         mplace1 := flip(data[11],data[12]);
  408.         mplace2 := flip(data[13],data[14]);
  409.         mplace3 := flip(data[15],data[16]);
  410.         mplace4 := flip(data[17],data[18]);
  411.         xdate(data[19],data[20],data[21],0,sealdate);
  412.         sealtemp := flip(data[22],data[23]);
  413.         hoth := flip(data[24],data[25]);
  414.         woth := flip(data[26],data[27]);
  415.         divflg := chr(data[28]);
  416.     END; {with}
  417. END; {unp_marr}
  418.  
  419. PROCEDURE unpack(pers:indiv;VAR x:irec);
  420.  
  421. {Extract INDIV2.DAT information into useable form. Arguments -
  422. Individual RECORD in BYTEs. Output - Individual RECORD expanded.}
  423.  
  424. VAR
  425.     i : INTEGER;
  426.  
  427. BEGIN {unpack}
  428.     WITH pers,x DO
  429.         BEGIN {with}
  430.             surname := flip(data[1],data[2]);
  431.             given1 := flip(data[3],data[4]);
  432.             given2 := flip(data[5],data[6]);
  433.             given3 := flip(data[7],data[8]);
  434.             title := flip(data[9],data[10]);
  435.             sex := chr(data[11]);
  436.             xdate(data[12],data[13],data[14],data[15],bdate);
  437.             bplace1 := flip(data[16],data[17]);
  438.             bplace2 := flip(data[18],data[19]);
  439.             bplace3 := flip(data[20],data[21]);
  440.             bplace4 := flip(data[22],data[23]);
  441.             xdate(data[24],data[25],data[26],data[27],cdate);
  442.             cplace1 := flip(data[28],data[29]);
  443.             cplace2 := flip(data[30],data[31]);
  444.             cplace3 := flip(data[32],data[33]);
  445.             cplace4 := flip(data[34],data[35]);
  446.             xdate(data[36],data[37],data[38],data[39],ddate);
  447.             dplace1 := flip(data[40],data[41]);
  448.             dplace2 := flip(data[42],data[43]);
  449.             dplace3 := flip(data[44],data[45]);
  450.             dplace4 := flip(data[46],data[47]);
  451.             xdate(data[48],data[49],data[50],data[51],budate);
  452.             buplace1 := flip(data[52],data[53]);
  453.             buplace2 := flip(data[54],data[55]);
  454.             buplace3 := flip(data[56],data[57]);
  455.             buplace4 := flip(data[58],data[59]);
  456.             xdate(data[60],data[61],data[62],0,bapdate);
  457.             baptemp := flip(data[63],data[64]);
  458.             xdate(data[65],data[66],data[67],0,endowdate);
  459.             endowtemp := flip(data[68],data[69]);
  460.             xdate(data[70],data[71],data[72],0,sealdate);
  461.             sealtemp := flip(data[73],data[74]);
  462.             sib := flip(data[75],data[76]);
  463.             marr := flip(data[77],data[78]);
  464.             pmarr := flip(data[79],data[80]);
  465.             for i := 1 to 10 DO
  466.                 id[i] := chr(data[80+i]);
  467.             note := flip(data[91],data[92]);
  468.         END; {with}
  469. END; {unpack}
  470.  
  471. PROCEDURE getnames(given1,given2,given3,surname,title,j:INTEGER;
  472.     VAR namlin,texlin:fline);
  473.  
  474. VAR
  475.     xx : fdate;
  476.     temp:fline;
  477.     i,len : INTEGER;
  478.     y : string[1];
  479.     yy : string[2];
  480.     yyy : string[3];
  481.     yyyy : string[4];
  482.     yyyyy : string[5];
  483.     cht:fchart;
  484.     pg:fmo;
  485.  
  486. PROCEDURE addname;
  487.  
  488. BEGIN
  489.     IF len > 0 THEN
  490.         BEGIN
  491.             FOR i := 1 to len DO
  492.                 BEGIN
  493.                     namlin := namlin+xx[i];
  494.                     IF index THEN
  495.                         index_entry := index_entry+xx[i]
  496.                 END;
  497.             namlin := namlin+' ';
  498.             IF index THEN
  499.                 index_entry := index_entry+' '
  500.         END
  501. END;
  502.  
  503. BEGIN {getnames}
  504.     namlin := '';
  505.     temp:='';
  506.     IF index THEN
  507.         index_entry := '';
  508.     gn(given1,len,xx);
  509.     addname;
  510.     gn(given2,len,xx);
  511.     addname;
  512.     gn(given3,len,xx);
  513.     addname;
  514.     gn(surname,len,xx);
  515.     IF index THEN
  516.         index_entry := ', ' + index_entry;
  517.     IF len > 0 THEN
  518.         BEGIN
  519.             FOR i := 1 to len DO {capitalise surname}
  520.                 IF (xx[i] >= 'a') and (xx[i] <='z') THEN
  521.                     xx[i]:=chr(ord(xx[i])-32);
  522.             IF (xx[1]='M') AND (xx[2]='C') THEN
  523.                 xx[2]:='c';
  524.             IF (xx[1]='M') AND (xx[2]='A') AND (xx[3]='C') THEN
  525.                 BEGIN
  526.                     xx[2]:='a';
  527.                     xx[3]:='c'
  528.                 END;
  529.             IF xx[3]=' ' THEN {De, N\'i, and suchlike}
  530.                 xx[2]:=chr(ord(xx[2])+32);
  531.             FOR i := 1 to len DO
  532.                 BEGIN
  533.                     namlin := namlin+xx[i];
  534.                     IF index THEN
  535.                         temp:= temp+xx[i];
  536.                 END;
  537.             namlin := namlin+' ';
  538.             IF index THEN
  539.                 index_entry := temp + index_entry
  540.         END;
  541.     gn(title,len,xx);
  542.     addname;
  543.     texlin:=namlin;
  544.     IF j>9999 THEN
  545.         BEGIN
  546.             str(j:5,yyyyy);
  547.             namlin := namlin+'('+yyyyy+')';
  548.             IF index THEN
  549.                 index_entry:=index_entry+'('+yyyyy+')'
  550.         END
  551.     ELSE
  552.         IF j>999 THEN
  553.             BEGIN
  554.                 str(j:4,yyyy);
  555.                 namlin := namlin+'('+yyyy+')';
  556.                 IF index THEN
  557.                     index_entry:=index_entry+'('+yyyy+')'
  558.             END
  559.         ELSE
  560.             IF j>99 THEN
  561.                 BEGIN
  562.                         str(j:3,yyy);
  563.                         namlin := namlin+'('+yyy+')';
  564.                         IF index THEN
  565.                             index_entry:=index_entry+'('+yyy+')'
  566.                 END
  567.             ELSE
  568.                 IF j>9 THEN
  569.                         BEGIN
  570.                             str(j:2,yy);
  571.                             namlin := namlin+'('+yy+')';
  572.                             IF index THEN
  573.                                 index_entry:=index_entry+'('+yy+')'
  574.                         END
  575.                 ELSE
  576.                         BEGIN
  577.                             str(j:1,y);
  578.                             namlin:=namlin+'('+y+')';
  579.                             IF index THEN
  580.                                 index_entry:=index_entry+'('+y+')'
  581.                         END;
  582.     If index THEN
  583.         BEGIN
  584.             STR(chartno:1:0,cht);
  585.             index_entry:=index_entry+' Chart '+cht;
  586.             IF NOT tex_on THEN
  587.                 BEGIN
  588.                     STR(page_no:4,pg);
  589.                     index_entry:=index_entry+' Page'+pg
  590.                 END
  591.             ELSE
  592.                 BEGIN
  593.                     STR(texpage:4,pg);
  594.                     index_entry:=index_entry+' Page'+pg
  595.                 END;
  596.             WRITELN(index_file,index_entry)
  597.         END
  598. END; {getnames}
  599.  
  600. PROCEDURE getdateplace
  601.     (date:fdate;place1,place2,place3,place4:INTEGER; VAR
  602.     lin:fline;VAR texlin:fline; VAR leng:INTEGER);
  603.  
  604. {The following lengthy routine extracts the best available date and place
  605. information for a birth/christening, marriage or death/burial
  606. and adds it to the output string. It may cause
  607. runtime overflow if too much information is available.}
  608.  
  609. VAR
  610.  
  611.     firstname:boolean;
  612.     xx : fdate;
  613.     i,len,offset : INTEGER;
  614.  
  615. PROCEDURE addname;
  616.  
  617. BEGIN {addname}
  618.  
  619.     IF firstname THEN {first place}
  620.         BEGIN
  621.             firstname:=false;
  622.             texlin := texlin + ' \it '
  623.         END
  624.     ELSE
  625.         BEGIN {subsequent places}
  626.             texlin:=texlin + ' ';
  627.             offset:=offset+1
  628.         END;
  629.     FOR i := 1 to len DO
  630.         BEGIN
  631.             lin := lin+xx[i];
  632.             texlin:=texlin+xx[i]
  633.         END;
  634.     lin := lin + ',';
  635.     texlin:=texlin + ',';
  636.     leng := leng + len + 1;
  637.  
  638. END; {addname}
  639.  
  640. BEGIN {getdateplace}
  641.  
  642.     firstname:=TRUE;
  643.     lin := '';
  644.     texlin := '';
  645.     leng := 0;
  646.     offset:=5;
  647.     IF length(date) > 3 THEN
  648.         BEGIN
  649.             lin := date + ' ';
  650.             texlin := date;
  651.             offset:=offset-1;
  652.             leng := length(date) + 1
  653.         END;
  654.     gn(place1,len,xx);
  655.     IF len > 0 THEN
  656.         addname;
  657.     gn(place2,len,xx);
  658.     IF len > 0 THEN
  659.         addname;
  660.     gn(place3,len,xx);
  661.     IF len > 0 THEN
  662.         addname;
  663.     gn(place4,len,xx);
  664.     IF len > 0 THEN
  665.         addname;
  666.     IF leng > (length(date) + 1) THEN
  667.         IF lin[leng-1]='.' THEN
  668.             BEGIN
  669.                 lin[leng]:=' ';
  670.                 texlin[leng+offset]:=' '
  671.             END
  672.         ELSE
  673.             BEGIN
  674.                 lin[leng]:='.';
  675.                 texlin[leng+offset]:='.'
  676.             END
  677.  
  678. END; {getdateplace}
  679.  
  680. PROCEDURE getperson(ind:irec; rin:INTEGER; VAR
  681.     namlin,birlin,birtex,dealin,deatex:fline; VAR
  682.     birlen,chrlen,dealen,burlen:INTEGER);
  683.  
  684. BEGIN {getperson}
  685.     WITH ind DO
  686.         BEGIN {with}
  687.             getnames(given1,given2,given3,
  688.                 surname,title,rin,namlin,tmplin);
  689.             getdateplace(bdate,bplace1,bplace2,bplace3,
  690.                 bplace4,birlin,birtex,birlen);
  691.             IF birlen=0 THEN
  692.                 getdateplace(cdate,cplace1,cplace2,cplace3,
  693.                         cplace4,birlin,birtex,chrlen);
  694.             getdateplace(ddate,dplace1,dplace2,dplace3,
  695.                 dplace4,dealin,deatex,dealen);
  696.             IF dealen=0 THEN
  697.                 getdateplace(budate,buplace1,buplace2,
  698.                         buplace3,buplace4,dealin,deatex,burlen);
  699.         END; {with}
  700. END; {getperson}
  701.  
  702. {PROCEDURE to build the line of information about an individual
  703. which will be printed in the descendants chart. Arguments - An
  704. INTEGER RIN (j is the VARiable). Output - a line of information
  705. <name,title,RIN,birthdate,birthplace,deathdate,deathplace>}
  706.  
  707. PROCEDURE wait;
  708.  
  709. BEGIN {wait}
  710.  
  711.     GOTOXY(5,24);
  712.     WRITE('Press <Enter> to continue ... ');
  713.     READ(ans)
  714.  
  715. END; {wait}
  716.  
  717. PROCEDURE heading;
  718.  
  719. {Produce a heading at the top of the page}
  720.  
  721. VAR
  722.     dash:INTEGER;
  723.  
  724. BEGIN {heading}
  725.     IF page_no<>1 THEN
  726.         BEGIN
  727.             IF printtofile THEN
  728.                 WRITELN(prnfile,chr(12));
  729.             IF print_on THEN
  730.                 WRITELN(lst,chr(12)) {FF}
  731.         END
  732.     ELSE
  733.         IF firstchart AND print_on THEN
  734.             BEGIN {first page}
  735.                 firstchart:=FALSE;
  736.                 GOTOXY(9,23);
  737.                 WRITELN('Adjust printer to top of page. Do not switch it off');
  738.                 wait
  739.             END; {first page}
  740.     IF print_on THEN
  741.         BEGIN
  742.             WRITELN(lst);
  743.             WRITELN(lst);
  744.             WRITE(lst,chr(27),chr(14));
  745.             WRITE(lst,'DESCENDANTS CHART FOR:');
  746.             WRITELN(lst);
  747.             WRITELN(lst);
  748.             WRITE(lst,chr(27),chr(14));
  749.             WRITELN(lst,hdg);
  750.             WRITELN(lst);
  751.             WRITE(lst,chr(27),chr(14));
  752.             WRITE(lst,date,'    Chart No:',chartno:10:0);
  753.             WRITE(lst,'    Page No:',page_no:4);
  754.             WRITELN(lst);
  755.             WRITELN(lst);
  756.             FOR dash:=1 to 132 DO
  757.                 WRITE(lst,'-');
  758.             WRITELN(lst);
  759.             WRITELN(lst)
  760.         END;
  761.     IF printtofile THEN
  762.         BEGIN
  763.             WRITELN(prnfile);
  764.             WRITELN(prnfile);
  765.             WRITE(prnfile,chr(27),chr(14));
  766.             WRITE(prnfile,'DESCENDANTS CHART FOR:');
  767.             WRITELN(prnfile);
  768.             WRITELN(prnfile);
  769.             WRITE(prnfile,chr(27),chr(14));
  770.             WRITELN(prnfile,hdg);
  771.             WRITELN(prnfile);
  772.             WRITE(prnfile,chr(27),chr(14));
  773.             WRITE(prnfile,date,'    Chart No:',chartno:10:0);
  774.             WRITE(prnfile,'    Page No:',page_no:4);
  775.             WRITELN(prnfile);
  776.             WRITELN(prnfile);
  777.             FOR dash:=1 to 132 DO
  778.                 WRITE(prnfile,'-');
  779.             WRITELN(prnfile);
  780.             WRITELN(prnfile)
  781.         END
  782. END; {heading}
  783.  
  784. PROCEDURE indent (j:INTEGER; VAR lin:fline);
  785.  
  786. VAR
  787.     i,k:INTEGER;
  788.  
  789. BEGIN {indent}
  790.     lin := '';
  791.     IF j>1 THEN
  792.     BEGIN
  793.     FOR i := 2 TO j-1 DO
  794.         BEGIN
  795.             FOR k := 1 TO indent_size-1 DO
  796.                 lin := lin + ' ';
  797.             IF youngest[i] AND lastmarr[i] THEN
  798.                 lin := lin + ' '
  799.             ELSE
  800.                 lin := lin + '|'
  801.         END;
  802.     FOR k := 1 TO indent_size-1 DO
  803.         lin := lin + ' ';
  804.     lin:=lin + '|'
  805.     END
  806. END; {indent}
  807. PROCEDURE tex_indent (j:INTEGER; VAR lin:fline);
  808.  
  809. VAR
  810.     i:INTEGER;
  811.  
  812. BEGIN {tex_indent}
  813.     lin := '';
  814.     IF j>1 THEN
  815.     BEGIN
  816.     FOR i := 2 TO j-1 DO
  817.         BEGIN
  818.             lin := lin + '\>';
  819.             IF NOT (youngest[i] AND lastmarr[i]) THEN
  820.                 lin := lin + '$|$'
  821.         END;
  822.     lin := lin + '\>$|$'
  823.     END
  824. END; {tex_indent}
  825.  
  826. PROCEDURE lineout(lin,tex_line:fline;marrline:boolean);
  827.  
  828. BEGIN {lineout}
  829.  
  830.     WRITELN(lin); {first the output to screen}
  831.     line_ct := succ(line_ct);
  832.     IF ((line_ct MOD lines_per_screen = 0) AND paging) THEN
  833.         BEGIN
  834.             WRITELN;
  835.             GOTOXY(5,24);
  836.             WRITE('Press S<Enter> to toggle scrolling,');
  837.             WRITE(' <Enter> to continue ... ');
  838.             READ(ans);
  839.             IF (ans='s') OR (ans='S') THEN
  840.                 paging:=FALSE;
  841.             WRITELN
  842.         END;
  843.     IF line_ct MOD lines_per_page = 0 THEN
  844.         page_no:=succ(page_no);
  845.     IF print_on THEN {second the output to ASCII printer}
  846.         BEGIN
  847.             WRITELN(lst,lin);
  848.             IF Line_ct MOD Lines_Per_Page = 0
  849.                 THEN heading
  850.         END;
  851.     IF printtofile THEN {third the output to print file}
  852.         BEGIN
  853.             WRITELN(prnfile,lin);
  854.             IF Line_ct MOD Lines_Per_Page = 0
  855.                 THEN heading
  856.         END;
  857.     IF tex_on THEN {fourth and last the output to TeX file}
  858.         BEGIN
  859.             WRITE(texfile,tex_line);
  860.             IF NOT marrline THEN
  861.                 WRITELN(texfile,'\\');
  862.             texline_ct := succ(texline_ct);
  863.             IF texline_ct MOD texlines_Per_Page = 0 THEN
  864.                 BEGIN
  865.                     texpage:=succ(texpage);
  866.                     WRITELN(texfile,'\end{paftab}');
  867.                     WRITELN(texfile,'\begin{paftab}')
  868.                 END
  869. END
  870.  
  871. END; {lineout}
  872.  
  873. PROCEDURE outperson(rin,gen:INTEGER;yy:twochr;VAR pers:irec);
  874.  
  875. VAR
  876.     ind:indiv;
  877.  
  878. BEGIN {outperson}
  879.     SEEK(INDIV2,rin);
  880.     READ(INDIV2,ind);
  881.     unpack(ind,pers);
  882.     getperson(pers,rin,namelin2,blin2,tex_blin2,dlin2,tex_dlin2,
  883.         blen,clen,dlen,bulen);
  884.     indent(gen,namelin);
  885.     tex_indent(gen,tex_nlin);
  886.     namelin := namelin + yy + '-' + namelin2;
  887.     tex_nlin := tex_nlin + yy + ' -- \bf ' + namelin2;
  888.     lineout(namelin,tex_nlin,marrln);
  889.     indent(gen,blin);
  890.     tex_indent(gen,tex_blin);
  891.     IF blen <> 0 THEN
  892.         BEGIN
  893.             blin := blin + ' -b. ' + blin2;
  894.             tex_blin := tex_blin + '\ b. ' + tex_blin2;
  895.             lineout(blin,tex_blin,marrln)
  896.         END
  897.     ELSE
  898.         IF clen <> 0 THEN
  899.             BEGIN
  900.                 blin := blin + ' -chr. ' + blin2;
  901.                     tex_blin := tex_blin + '\ chr. ' + tex_blin2;
  902.                 lineout(blin,tex_blin,marrln)
  903.             END;
  904.     indent(gen,dlin);
  905.     tex_indent(gen,tex_dlin);
  906.     IF dlen <> 0 THEN
  907.         BEGIN
  908.             dlin := dlin + ' -d. ' + dlin2;
  909.             tex_dlin := tex_dlin + '\ d. ' + tex_dlin2;
  910.             lineout(dlin,tex_dlin,marrln)
  911.         END
  912.     ELSE
  913.         IF bulen <> 0 THEN
  914.             BEGIN
  915.                 dlin := dlin + ' -bur. ' + dlin2;
  916.                     tex_dlin := tex_dlin + '\ bur. ' + tex_dlin2;
  917.                     lineout(dlin,tex_dlin,marrln)
  918.             END;
  919. END; {out_person}
  920.  
  921. PROCEDURE out_marr(wedding:mar;gen:INTEGER);
  922.  
  923. VAR
  924.     tex_mlin2,mlin2:fline;
  925.     mlen:INTEGER;
  926.     marr_no:string[1];
  927.  
  928. BEGIN {out_marr}
  929.     WITH wedding DO
  930.         BEGIN
  931.             indent(gen,mlin);
  932.             tex_indent(gen,tex_mlin);
  933.             getdateplace(mardate,mplace1,mplace2,mplace3,
  934.                 mplace4,mlin2,tex_mlin2,mlen);
  935.             mlin := mlin + ' -m.';
  936.             tex_mlin := tex_mlin + '\ m.';
  937.             IF multmarr THEN
  938.                 BEGIN
  939.                     str(wed_no,marr_no);
  940.                     mlin := mlin + '(' + marr_no + ')';
  941.                     tex_mlin := tex_mlin + '(' + marr_no + ')'
  942.                 END;
  943.             mlin := mlin + ' ' + mlin2;
  944.             IF tex_mlin2 <> '' THEN
  945.                 tex_mlin := tex_mlin + ' ' + tex_mlin2;
  946.             marrln:=TRUE;
  947.             lineout(mlin,tex_mlin,marrln);
  948.             marrln:=FALSE;
  949.         END
  950. END; {out_marr}
  951.  
  952. PROCEDURE prsetup(rin:INTEGER);
  953.  
  954. VAR
  955.     ind:indiv;
  956.     pers:irec;
  957.     temp:boolean;
  958.  
  959. BEGIN {prsetup}
  960.     SEEK(INDIV2,rin);
  961.     READ(INDIV2,ind);
  962.     unpack(ind,pers);
  963.     temp:=index;
  964.     index:=false; {to prevent duplicate index entry for heading individual}
  965.     WITH pers DO
  966.         getnames(given1,given2,given3,surname,title,rin,hdg,texhdg);
  967.     index:=temp;
  968.     IF NOT bothrem THEN
  969.         BEGIN
  970.             total_pages:=total_pages+page_no;
  971.             page_no := 1;
  972.             texpage:=1
  973.         END
  974.     ELSE
  975.         bothrem := false;
  976.     line_ct := 1;
  977.     texline_ct := 1;
  978.     IF print_on OR printtofile THEN
  979.         heading;
  980. END; {prsetup}
  981.  
  982. PROCEDURE getroot(VAR rin:INTEGER; VAR pers:irec);
  983.  
  984. VAR
  985.     ind:indiv;
  986.  
  987. BEGIN {getroot}
  988.  
  989.     GOTOXY(9,21);
  990.     WRITE('Enter the RIN: ');
  991.     READ(rin);
  992.     SEEK(INDIV2,rin);
  993.     READ(INDIV2,ind);
  994.     unpack(ind,pers)
  995.  
  996. END; {getroot}
  997.  
  998. PROCEDURE startoutput;
  999.  
  1000. BEGIN {startoutput}
  1001.  
  1002.     IF index THEN
  1003.         BEGIN
  1004.             GOTOXY(9,21);
  1005.             WRITE('Index file will be cleared!! ');
  1006.             WRITE('Use another program to sort the index file.');
  1007.             GOTOXY(9,22);
  1008.             WRITE('Enter full pathname for index file : ');
  1009.             READLN(file_name);
  1010.             ASSIGN(index_file,file_name);
  1011.             REWRITE(index_file);
  1012.             IF printtofile OR tex_on THEN {tidy display}
  1013.                 mainmenu
  1014.         END;
  1015.     IF printtofile THEN
  1016.         BEGIN
  1017.             GOTOXY(9,21);
  1018.             WRITE('Print file will be cleared!!');
  1019.             GOTOXY(9,22);
  1020.             WRITE('Enter full pathname for print file : ');
  1021.             READLN(file_name);
  1022.             ASSIGN(prnfile,file_name);
  1023.             REWRITE(prnfile);
  1024.             IF tex_on THEN
  1025.                 mainmenu
  1026.         END;
  1027.     IF tex_on THEN
  1028.         BEGIN
  1029.             GOTOXY(9,21);
  1030.             WRITE('Use default file TEMP.TEX? (Y/N): ');
  1031.             READLN(ans);
  1032.             IF (ans='Y') OR (ans='y') THEN
  1033.                 file_name:='temp.tex'
  1034.             ELSE
  1035.                 BEGIN
  1036.                     GOTOXY(9,21);
  1037.                     WRITE('TeX file will be cleared!! Extension must be .TeX');
  1038.                     GOTOXY(9,22);
  1039.                     WRITE('Enter full pathname for TeX file : ');
  1040.                     READLN(file_name)
  1041.                 END;
  1042.             ASSIGN(texfile,file_name);
  1043.             REWRITE(texfile)
  1044.         END
  1045.  
  1046. END; {startoutput}
  1047.  
  1048. PROCEDURE nodups(mrin:INTEGER;VAR skip:BOOLEAN;VAR chart,page:INTEGER);
  1049.  
  1050. {Procedure to check whether and on which chart the offspring of
  1051. the current marriage have already appeared.}
  1052.  
  1053. VAR
  1054.     i:INTEGER;
  1055.  
  1056. BEGIN {nodups}
  1057.     i:=1;
  1058.     WHILE (i<=famsdone) AND (famdone[i].mrino<>mrin) DO
  1059.         i:=i+1;
  1060.     skip:= (i<>famsdone+1);
  1061.     IF skip THEN
  1062.         BEGIN
  1063.             chart:=round(famdone[i].chrt); {must be an integer}
  1064.             page:=famdone[i].pg
  1065.         END
  1066.     ELSE
  1067.         BEGIN
  1068.             famsdone:=famsdone+1;
  1069.             WITH famdone[i] DO
  1070.                 BEGIN
  1071.                     mrino:=mrin;
  1072.                     chrt:=chartno;
  1073.                     IF tex_on THEN
  1074.                         pg:=texpage
  1075.                     ELSE
  1076.                         pg:=page_no
  1077.                 END
  1078.         END
  1079. END; {nodups}
  1080.  
  1081. PROCEDURE descend_top(rin:INTEGER);
  1082.  
  1083. {Top level of the Descent Chart Process.}
  1084.  
  1085. VAR
  1086.     ind:indiv;
  1087.     pers:irec;
  1088.     i:INTEGER;
  1089.  
  1090. PROCEDURE descend(rin,gen:INTEGER);
  1091.  
  1092. {Recursive sub-procedure to traverse the family descent and print
  1093. the lines of the descent chart. This routine must be studied
  1094. carefully to understand. The basic functions are:
  1095. 1. Print the individual referred to by RIN.
  1096. 2. Build a list of all marriages of that person.
  1097. 3. For each marriage:
  1098.     a. Print the spouse - IF any.
  1099.     b. Build a list of all children of the marriage.
  1100.     c. For each child (in order of birth):
  1101.         1) Recurse down one generation.
  1102. Arguments - RIN, generation #. Output - the report.}
  1103.  
  1104. VAR
  1105.     i,j,k,m,curr_mar,curr_child : INTEGER;
  1106.     yy : string[2];
  1107.     ind,ind1 : indiv;
  1108.     pers,pers1 : irec;
  1109.     m1 : marr;
  1110.     m2 : mar;
  1111.     p : genptr;
  1112.     g : genrec;
  1113.     done,temptex : BOOLEAN;
  1114.     tempstr : fchart;
  1115.     temp : string[1];
  1116.  
  1117. BEGIN {descend}
  1118.     SEEK(INDIV2,rin);
  1119.     READ(INDIV2,ind1);
  1120.     unpack(ind1,pers1);
  1121.     IF (gen<=No_Gen) AND (NOT maleline OR (pers1.sex='M')) THEN
  1122.     BEGIN {output}
  1123.         IF gen<10 THEN
  1124.             BEGIN
  1125.             str(gen:1,temp);
  1126.             yy:=temp + ' '
  1127.             END
  1128.         ELSE
  1129.             str(gen:2,yy);
  1130.         outperson(rin,gen,yy,pers);
  1131.             IF pers.marr <> 0 THEN
  1132.                 BEGIN {LOOK AT ALL MARRIAGES}
  1133.                         new(p);
  1134.                         p^.marptr := 0;
  1135.                         p^.chptr := 0;
  1136.                         done := False;
  1137.                         m := pers.marr;
  1138.                         i := 1;
  1139.                         WHILE NOT done DO
  1140.                             BEGIN {LOOK AT ANOTHER MARRIAGE}
  1141.                                 SEEK(MARR2,m);
  1142.                                 READ(MARR2,m1);
  1143.                                 unp_marr(m1,m2);
  1144.                                 p^.marptr := i;
  1145.                                 p^.mar[i] := m;
  1146.                                 IF pers.sex = 'M' THEN
  1147.                                     IF m2.hoth <> 0 THEN
  1148.                                             BEGIN
  1149.                                                 m := m2.hoth;
  1150.                                                 i := i+1;
  1151.                                             END
  1152.                                     ELSE
  1153.                                             done := True
  1154.                                 ELSE
  1155.                                     IF m2.woth <> 0 THEN
  1156.                                             BEGIN
  1157.                                                 m := m2.woth;
  1158.                                                 i := i+1;
  1159.                                             END
  1160.                                     ELSE
  1161.                                             done := True;
  1162.                             END; {LOOK AT ANOTHER MARRIAGE}
  1163.                         FOR j := 1 to p^.marptr DO
  1164.                             BEGIN {PROCESS jTH MARRIAGE}
  1165.                                 curr_mar := p^.mar[j];
  1166.                                 SEEK(MARR2,curr_mar);
  1167.                                 READ(MARR2,m1);
  1168.                                 unp_marr(m1,m2);
  1169.                                 wed_no:=j;
  1170.                                 multmarr:=(p^.marptr<>1);
  1171.                                 lastmarr[gen]:=(j=p^.marptr);
  1172.                                 out_marr(m2,gen);
  1173.                                 IF m2.child <> 0 THEN
  1174.                                     BEGIN {see if already output}
  1175.                                     nodups(curr_mar,skipfam,orchart,orpg);
  1176.                                     IF tex_on THEN
  1177.                                     IF skipfam THEN
  1178.                                     BEGIN {omit all children}
  1179.                                         WRITE(texfile,'\protect\footnote{');
  1180.                                         WRITE(texfile,'See chart no.\ ');
  1181.                                         WRITE(texfile,orchart,' page no.\ ');
  1182.                                         WRITE(texfile,orpg,' for descendants.');
  1183.                                         WRITE(texfile,'}')
  1184.                                     END {omit all children}
  1185.                                     END; {see if already output}
  1186.                                     IF tex_on THEN
  1187.                                     WRITELN(texfile,'\\');
  1188.                                 IF pers.sex = 'M' THEN 
  1189.                                     IF m2.wIFe <> 0 THEN
  1190.                                             BEGIN
  1191.                                             yy := 's ';
  1192.                                             outperson(m2.wife,
  1193.                                                 gen,yy,pers1);
  1194.                                             END;
  1195.                                 IF pers.sex = 'F' THEN
  1196.                                     IF m2.husb <> 0 THEN
  1197.                                             BEGIN
  1198.                                             yy := 's ';
  1199.                                             outperson(m2.husb,
  1200.                                                 gen,yy,pers1);
  1201.                                             END;
  1202.                                 IF m2.child <> 0 THEN
  1203.                                     BEGIN {see if already output}
  1204.                                     IF skipfam THEN
  1205.                                     BEGIN {omit all children}
  1206.                                         temptex:=tex_on;
  1207.                                         tex_on:=false;{disable since fn done}
  1208.                                         indent(gen,ref2);
  1209.                                         lineout(ref2,tex_mlin,marrln);
  1210.                                         ref2:=ref2+'See chart no. ';
  1211.                                         STR(orchart:10,tempstr);
  1212.                                         ref2:=ref2+tempstr;
  1213.                                         ref2:=ref2+' page no.';
  1214.                                         STR(orpg:5,tempstr);
  1215.                                         ref2:=ref2+tempstr;
  1216.                                         ref2:=ref2+' for descendants.';
  1217.                                         lineout(ref2,tex_mlin,marrln);
  1218.                                         indent(gen,ref2);
  1219.                                         lineout(ref2,tex_mlin,marrln);
  1220.                                         tex_on:=temptex
  1221.                                     END {omit all children}
  1222.                                     ELSE
  1223.                                     BEGIN { COLLECT CHILDREN}
  1224.                                         p^.chptr := 1;
  1225.                                         done := False;
  1226.                                         k := m2.child;
  1227.                                         p^.child[p^.chptr]:=k;
  1228.                                         while not done DO
  1229.                                         BEGIN {GET NEXT CHILD}
  1230.                                         SEEK(INDIV2,k);
  1231.                                         READ(INDIV2,ind1);
  1232.                                         unpack(ind1,pers1);
  1233.                                         IF pers1.sib<>0 THEN
  1234.                                         BEGIN
  1235.                                     p^.chptr:=p^.chptr+1;
  1236.                                     k := pers1.sib;
  1237.                                     p^.child[p^.chptr]:=k;
  1238.                                         END
  1239.                                         ELSE
  1240.                                         done := True;
  1241.                                         END; {GET NEXT CHILD}
  1242.                                     END {COLLECT CHILDREN}
  1243.                                     END; {see if already output}
  1244.                                 FOR i := p^.chptr downto 1 DO
  1245.                                 BEGIN
  1246.                                     curr_child := p^.child[i];
  1247.                                     youngest[gen+1]:=(i=1);
  1248.                                     descend(curr_child,gen+1);
  1249.                                 END;
  1250.                                 p^.chptr := 0;
  1251.                             END; {process jth marriage}
  1252.                 END; {look at all marriages}
  1253.         mark(p);
  1254.     END; {output}
  1255. END; {descend}
  1256.  
  1257. BEGIN {Main body of descend_top; process an entire chart}
  1258.  
  1259.     prsetup(rin);
  1260.     CLRSCR;
  1261.     WRITELN(no_gen,' Generation chart (no. ',chartno:1:0,') for ',hdg);
  1262.     IF tex_on THEN
  1263.         BEGIN
  1264.             WRITE(texfile,'\begin{chart}');
  1265.             WRITELN(texfile,'{',chartno:1:0,'}{',texhdg,'}{',rin,'}');
  1266.             WRITELN(texfile,'\begin{paftab}')
  1267.         END;
  1268.     descend(rin,1);
  1269.     IF print_on THEN
  1270.         WRITE(lst,chr(12)); {    FF    }
  1271.     IF printtofile THEN
  1272.         WRITE(prnfile,chr(12));
  1273.     IF tex_on THEN
  1274.             WRITELN(texfile,'\end{paftab}\end{chart}');
  1275.     IF paging THEN
  1276.         BEGIN
  1277.             writeln;
  1278.             wait
  1279.         END
  1280.  
  1281. END; {descend_top}
  1282.  
  1283. PROCEDURE ascend(wedding:INTEGER);
  1284.  
  1285. VAR
  1286.     m1:marr;
  1287.     m2:mar;
  1288.     da,ma:indiv;
  1289.     father,mother:irec;
  1290.  
  1291. FUNCTION doachart(whoever:irec):BOOLEAN;
  1292.  
  1293. BEGIN
  1294.     doachart:=(whoever.pmarr=0) OR (chartno>=maxchart/2)
  1295. END;
  1296.  
  1297. PROCEDURE pop;
  1298.  
  1299. VAR
  1300.     tmptr:ascptr;
  1301.  
  1302. BEGIN {pop}
  1303.     IF stacksize > 0 THEN
  1304.         BEGIN {pop stack}
  1305.             stacksize:=stacksize-1;
  1306.             tmptr:=p;
  1307.             p:=p^.lp;
  1308.             WITH tmptr^ DO
  1309.         begin
  1310.         chartno := tafel;
  1311.         parents_marr := marptr;
  1312.         end;
  1313.         END {pop stack}
  1314.  else
  1315.     alldone := true
  1316. END; {pop}
  1317.  
  1318. BEGIN {ascend}
  1319.     IF wedding <> 0 THEN
  1320.         BEGIN {unpack and process}
  1321.             SEEK(MARR2,wedding);
  1322.             READ(MARR2,m1);
  1323.             unp_marr(m1,m2);
  1324.             IF m2.husb <> 0 THEN
  1325.                 BEGIN
  1326.                         SEEK(INDIV2,m2.husb);
  1327.                         READ(INDIV2,da);
  1328.                         unpack(da,father);
  1329.                 END;
  1330.             IF (m2.wIFe <> 0) AND (chartno<maxchart/2) THEN
  1331.                 BEGIN {stack maternal side}
  1332.                         stacksize:=stacksize+1;
  1333.                         SEEK(INDIV2,m2.wIFe);
  1334.                         READ(INDIV2,ma);
  1335.                         unpack(ma,mother);
  1336.                         IF stacksize=1 THEN
  1337.                             BEGIN
  1338.                                 new(stacktop);
  1339.                                 p:=stacktop;
  1340.                             END
  1341.                         ELSE
  1342.                             BEGIN
  1343.                                 new(p^.rp);
  1344.                                 p^.rp^.lp:=p;
  1345.                                 p:=p^.rp;
  1346.                             END;
  1347.                         p^.marptr:=mother.pmarr;
  1348.                         p^.wIFptr:=m2.wIFe;
  1349.                         p^.tafel:=2*chartno+1;
  1350.                 END; {stack maternal side}
  1351.             WITH m2 DO
  1352.                 BEGIN {next chart}
  1353.                         IF woth <> 0 THEN
  1354.                             BEGIN {other wives}
  1355.                             IF surname THEN
  1356.                             BEGIN
  1357.                                 IF doachart(mother) THEN
  1358.                                 descend_top(wife)
  1359.                             END
  1360.                             ELSE
  1361.                             descend_top(wife);
  1362.                             IF hoth <> 0 THEN
  1363.                                 IF surname THEN
  1364.                                 BEGIN
  1365.                                     IF doachart(father) THEN
  1366.                                     descend_top(husb)
  1367.                                 END
  1368.                                 ELSE
  1369.                                 BEGIN
  1370.                                     WRITE('Both spouses');
  1371.                                     WRITE('remarried');
  1372.                                     WRITE(' - printing 2');
  1373.                                     WRITELN(' charts (same number)');
  1374.                                     bothrem:=true;
  1375.                                     descend_top(husb)
  1376.                                 END
  1377.                             END {other wives}
  1378.                         ELSE
  1379.                             IF husb <> 0 THEN
  1380.                             IF surname THEN
  1381.                                 BEGIN
  1382.                                 IF doachart(father) THEN
  1383.                                     descend_top(husb)
  1384.                                 END
  1385.                             ELSE
  1386.                                 descend_top(husb)
  1387.                             ELSE
  1388.                             IF surname THEN
  1389.                                 BEGIN
  1390.                                 IF doachart(mother) THEN
  1391.                                     descend_top(wife)
  1392.                                 END
  1393.                             ELSE
  1394.                                 descend_top(wife);
  1395.                         IF (husb <> 0) AND (chartno<maxchart/2) THEN
  1396.         begin
  1397.             parents_marr := father.pmarr;
  1398.             chartno := 2*chartno
  1399.         end
  1400.                         ELSE
  1401.                             pop
  1402.                 END {next chart}
  1403.         END {unpack and process}
  1404.     ELSE
  1405.         IF chartno=1 THEN
  1406.             BEGIN {no ancestors}
  1407.                 GOTOXY(9,21);
  1408.                 WRITE('No ancestors entered for this');
  1409.                 WRITE(' person. (RIN: ',root,'.)');
  1410.                 GOTOXY(9,22);
  1411.                 IF baserec.sex = 'M' THEN
  1412.                         WRITE('His ')
  1413.                 ELSE
  1414.                         WRITE('Her ');
  1415.                 WRITE('descendants chart will be printed.');
  1416.                 wait;
  1417.                 descend_top(root);
  1418.                 alldone:=TRUE
  1419.             END {no ancestors}
  1420.         ELSE
  1421.             pop
  1422. END; {ascend}
  1423.  
  1424. PROCEDURE statistics;
  1425.  
  1426. BEGIN {statistics}
  1427.  
  1428.     WRITELN;
  1429.     WRITELN('Total number of families (with children) processed: ',famsdone);
  1430.     WRITELN;
  1431.     WRITELN('Total number of pages printed: ',total_pages);
  1432.     WRITELN;
  1433.     wait;
  1434.     IF index THEN
  1435.         close(index_file);
  1436.     IF printtofile THEN
  1437.         close(prnfile);
  1438.     IF tex_on THEN
  1439.         close(texfile)
  1440.  
  1441. END; {statistics}
  1442.  
  1443. PROCEDURE cascade;
  1444.  
  1445. BEGIN {cascade}
  1446.     stacksize:=0;
  1447.     total_pages:=0;
  1448.     startoutput;
  1449.     parents_marr := baserec.pmarr;
  1450.     alldone := false;
  1451.     REPEAT
  1452.         ascend(parents_marr)
  1453.     UNTIL alldone;
  1454.     total_pages:=total_pages+page_no;
  1455.     statistics
  1456. END; {cascade}
  1457.  
  1458. PROCEDURE getdata;
  1459.  
  1460. {The DOS SUBST command should be used to make E: correspond to
  1461. the appropriate pathname.}
  1462.  
  1463. BEGIN {getdata}
  1464.     ASSIGN(NAME2,'E:NAME2.DAT');
  1465.     RESET(NAME2);
  1466.     ASSIGN(INDIV2,'E:INDIV2.DAT');
  1467.     RESET(INDIV2);
  1468.     ASSIGN(MARR2,'E:MARR2.DAT');
  1469.     RESET(MARR2);
  1470. END; {getdata}
  1471.  
  1472. PROCEDURE welcome;
  1473.  
  1474. BEGIN {welcome}
  1475.  
  1476.     CLRSCR;
  1477.     GOTOXY(11,2);
  1478.     WRITE('Welcome to CASCADE: a PAF utility program by Patrick Waldron');
  1479.     GOTOXY(11,3);
  1480.     WRITE('============================================================');
  1481.     GOTOXY(31,5);
  1482.     WRITE(date);
  1483.     GOTOXY(29,7);
  1484.     WRITE('Version 1.3. 17 Feb 1991.');
  1485.     GOTOXY(1,9);
  1486.     WRITELN('*WARNING* Before running CASCADE, it is essential to issue the');
  1487.     WRITELN('    DOS command "subst e: <pathname>" where <pathname> is');
  1488.     WRITELN('    the location of your PAF data files. Otherwise, an I/O');
  1489.     WRITELN('    error will occur when you now hit <Enter>.');
  1490.     GOTOXY(1,14);
  1491.     WRITE('If you find this program useful please send IR#10 or equivalent to');
  1492.     GOTOXY(9,15);
  1493.     WRITE('P. J. M. Waldron');
  1494.     GOTOXY(9,16);
  1495.     WRITE('39 Park Drive');
  1496.     GOTOXY(9,17);
  1497.     WRITE('Dublin 6');
  1498.     GOTOXY(9,18);
  1499.     WRITE('IRELAND');
  1500.     GOTOXY(1,19);
  1501.     WRITE('or to your favourite charity.');
  1502.     GOTOXY(1,21);
  1503.     WRITE('Send a SASE or 2 IRCs to the above address if you have queries,');
  1504.     WRITELN(' bug reports');
  1505.     WRITE('or suggestions, or if you want information on updates.');
  1506.     wait
  1507.  
  1508. END; {welcome}
  1509.  
  1510. PROCEDURE initialise;
  1511.  
  1512. VAR
  1513.     ind:indiv;
  1514.  
  1515. BEGIN {initialise}
  1516.  
  1517.     marrln:=FALSE;
  1518.     paging:=TRUE;
  1519.     maleline:=FALSE;
  1520.     print_on:=FALSE;
  1521.     surname:=FALSE;
  1522.     index:=FALSE;
  1523.     printtofile:=FALSE;
  1524.     tex_on:=FALSE;
  1525.     no_gen:=maxgen;
  1526.     nogen_up:=6;
  1527.     maxchart:=64;
  1528.     root:=1;
  1529.     SEEK(INDIV2,root);
  1530.     READ(INDIV2,ind);
  1531.     unpack(ind,baserec)
  1532.  
  1533. END; {initialise}
  1534.  
  1535. PROCEDURE switchprinteron;
  1536.  
  1537. BEGIN {switchprinteron}
  1538.  
  1539.     IF print_on THEN
  1540.         BEGIN
  1541.             GOTOXY(1,21);
  1542.             WRITELN('Initialising printer ... ');
  1543.             WRITELN('Switch on printer/adjust to TOF.');
  1544.             wait;
  1545.             WRITE(lst,chr(27)+'0',chr(15))
  1546.         END
  1547.     ELSE
  1548.         WRITE(lst,chr(27)+'@')
  1549.  
  1550. END; {switchprinteron}
  1551.  
  1552. PROCEDURE gencheck;
  1553.  
  1554. BEGIN
  1555.  
  1556.     IF surname AND (nogen_up>=no_gen) THEN
  1557.         BEGIN
  1558.             nogen_up:=no_gen-1;
  1559.             maxchart:=exp(nogen_up*ln(2));
  1560.             mainmenu;
  1561.             GOTOXY(9,21);
  1562.             WRITE('***** WARNING ***** (see CASCADE.DOC)');
  1563.             GOTOXY(9,22);
  1564.             WRITE('Surname option requires minimum generations per chart.');
  1565.             GOTOXY(9,23);
  1566.             WRITE('No. of generations to cascade has been reset to ');
  1567.             WRITE(nogen_up,'.');
  1568.             wait
  1569.         END
  1570.  
  1571. END;
  1572.  
  1573. BEGIN {main}
  1574.  
  1575.     done := false;
  1576.     bothrem:= false;
  1577.     welcome;
  1578.     getdata;
  1579.     initialise;
  1580.     while not done DO
  1581.         BEGIN {WHILE}
  1582.             famsdone:=0;
  1583.             page_no:=0;
  1584.             texpage:=0;
  1585.             chartno:=1;
  1586.             firstchart:=TRUE;
  1587.             mainmenu;
  1588.             READLN(Ans);
  1589.             CASE ans OF
  1590.         '1': paging:=NOT paging;
  1591.         '2': maleline:=NOT maleline;
  1592.         '3': BEGIN
  1593.             print_on := NOT print_on;
  1594.             switchprinteron
  1595.         END;
  1596.         '4': BEGIN
  1597.             surname := NOT surname;
  1598.             gencheck
  1599.         END;
  1600.         '5': index:=NOT index;
  1601.         '6': printtofile:=NOT printtofile;
  1602.         '7': tex_on:=NOT tex_on;
  1603.         '8': BEGIN
  1604.             GOTOXY(9,21);
  1605.             WRITE('How many generations on each descendants chart? ');
  1606.             READ(no_gen);
  1607.             gencheck
  1608.         END;
  1609.         '9': BEGIN
  1610.             GOTOXY(9,21);
  1611.                     WRITE('Cascade back how many generations? ');
  1612.                     READ(nogen_up);
  1613.                     maxchart:=exp(nogen_up*ln(2));
  1614.                     gencheck
  1615.         END;
  1616.                 'A': getroot(root,baserec);
  1617.                 'a': getroot(root,baserec);
  1618.                 'B': BEGIN
  1619.                         startoutput;
  1620.                         descend_top(root);
  1621.                         total_pages:=page_no;
  1622.                         statistics
  1623.                 END;
  1624.                 'b': BEGIN
  1625.                         startoutput;
  1626.                         descend_top(root);
  1627.                         total_pages:=page_no;
  1628.                         statistics
  1629.                 END;
  1630.                 'C': IF maleline THEN
  1631.                             BEGIN
  1632.                                 GOTOXY(9,21);
  1633.                                 WRITE('Cannot cascade with maleline flag on.');
  1634.                                 wait
  1635.                             END
  1636.                         ELSE
  1637.                             cascade;
  1638.                 'c': IF maleline THEN
  1639.                             BEGIN
  1640.                                 GOTOXY(9,21);
  1641.                                 WRITE('Cannot cascade with maleline flag on.');
  1642.                                 wait
  1643.                             END
  1644.                         ELSE
  1645.                             cascade;
  1646.                 '0': done := true
  1647.             END {CASE}
  1648.         END; {WHILE}
  1649.     CLRSCR
  1650. END. {main}
  1651.